perm filename CALC.F4[2,VDS]2 blob sn#160624 filedate 1975-05-17 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00034 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00004 00002	C     MAIN PROGRAM -- "LOOK-UP"
C00016 00003	      SUBROUTINE OUTPUT (PRINT)
C00025 00004	      SUBROUTINE CONTRL (START, PRINT)
C00028 00005	      SUBROUTINE UPDATE (START)
C00038 00006	      SUBROUTINE MESAGE (ERR, RTRN)
C00045 00007	      SUBROUTINE CLEAR
C00048 00008	      SUBROUTINE RPAREN
C00052 00009	      SUBROUTINE EQUAL
C00056 00010	      SUBROUTINE SIGN
C00059 00011	      SUBROUTINE FUNCTN (START)
C00063 00012	      SUBROUTINE SEMI
C00066 00013	      SUBROUTINE IMEDEX
C00069 00014	      SUBROUTINE COLAPS (RTRN)
C00075 00015	      SUBROUTINE COMBIN (A, NARGS)
C00082 00016	      SUBROUTINE ENTRY
C00085 00017	      SUBROUTINE DIGIT
C00088 00018	      SUBROUTINE ENTEXP
C00091 00019	      SUBROUTINE CORECT (START)
C00095 00020	      SUBROUTINE ADEXPD (RTRN)
C00098 00021	      SUBROUTINE RECALL (START)
C00101 00022	      SUBROUTINE STORE (START)
C00108 00023	      SUBROUTINE SCR (START)
C00111 00024	      SUBROUTINE LSTKEY
C00114 00025	      SUBROUTINE FLAG (START)
C00116 00026	      SUBROUTINE SETUP (RTRN)
C00119 00027	      SUBROUTINE ENTRUP
C00122 00028	      SUBROUTINE NUMBER (START, RTRN)
C00125 00029	      SUBROUTINE FINDN (START, RTRN)
C00128 00030	      SUBROUTINE REG (RTRN)
C00132 00031	      SUBROUTINE RANGE (RTRN)
C00135 00032	      SUBROUTINE ARGMNT (START)
C00141 00033	      SUBROUTINE ROUND
C00145 00034	      SUBROUTINE FDIGIT (START, RTRN)
C00148 ENDMK
C⊗;
C     MAIN PROGRAM -- "LOOK-UP"
C         DATE OF LAST CHANGE - 750104
          IMPLICIT INTEGER (A-Z)
          LOGICAL START, NEXT, FIXFLG, TRUE
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /OUTPT/ SKIP, DISPLY(32), PGMPTR
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
   10     DO 20 I=2,21
             DO 20 J=1,17
                IF (J.LT.12) UFLAG(J)=0
   20           R(I,J)=15
          R(21,2)=1
          R(21,3)=5
          DO 30 I=4,16
   30        R(21,I)=0
          R(21,17)=1
C
C      REGISTERS ARE ALLOCATED AS FOLLOWS:  R(1)="PI", R(2)="A",
C         R(3)="LST X", R(4)="LST Y", R(5)="R0", ..., R(20)="R15",
C         R(21)="HIGHEST REG NUMBER AVAILABLE"
C
C ** CONTROL PARAMETERS
C
C      SKIP   = OUTPUT CONTROL (0 -> FULL STACK, 1 -> SHORT STACK,
C                               2 -> DISPLAY, 3 -> DISPLAY & REGISTERS)
C      FIXFLG = "DISPLAY" CONTROL (T -> "FIX" MODE)
C      FIX    = NUMBER OF DECIMAL DIGITS IN "FIX" MODE (0-9)
C      SCI    = NUMBER OF DIGITS IN "SCI" MODE (1-10)
C      SMAX   = NUMBER OF REGISTERS IN THE "STACK"
C
          SKIP=3
          FIXFLG=.TRUE.
          FIX=2
          SCI=5
          SMAX=7
C
          TYPE 1000
          ACCEPT 1600, START
          IF (START) GO TO 50
             TYPE 1100
             ACCEPT 1700, SKIP
             TYPE 1200
             ACCEPT 1600, START
             IF (START) GO TO 40
                TYPE 1300
                ACCEPT 1600, FIXFLG
                TYPE 1400
                ACCEPT 1800, FIX, SCI
                SCI=SCI+1
   40        TYPE 1500
             ACCEPT 1700, SMAX
C      CONSIDER 100 TEST EQUATIONS
   50     DO 340 TEST=1,100
             ERROR=0
             OLD=1
             DO 60 I=1,50
   60           EXPR(I)=15
             CALL CLEAR
             TYPE 1900, TEST
             CALL OUTPUT (-1)
             KEY=0
C      OUTPUT CURRENT INFO & OBTAIN NEXT KEY-CODE
   70        CALL CONTRL (1, SKIP)
C      DECODE KEY-CODE
                IF (NEXT) NEXT=.FALSE.
                IF (CODE.LE.12) GO TO 80
                IF (CODE.EQ.13 .OR. CODE.EQ.14) GO TO 90
                IF (CODE.GT.15.AND.CODE.LT.20.AND.CODE.NE.18) GO TO 100
                IF (CODE.EQ.18) GO TO 110
                IF (CODE.EQ.20) GO TO 120
                IF (CODE.EQ.22) GO TO 130
                IF (CODE.GT.22 .AND. CODE.LT.25 .OR.
     *              CODE.EQ.38 .OR. CODE.EQ.39) GO TO 170
                IF (CODE.EQ.25) GO TO 180
                IF (CODE.EQ.26) GO TO 190
                IF (CODE.EQ.27) GO TO 200
                IF (CODE.EQ.28) GO TO 210
                IF (CODE.EQ.29) GO TO 220
                IF (CODE.EQ.31) GO TO 230
                IF (CODE.EQ.32) GO TO 240
                IF (CODE.EQ.33) GO TO 250
                IF (CODE.EQ.34) GO TO 260
                IF (CODE.EQ.35) GO TO 270
                IF (CODE.EQ.36) GO TO 280
                IF (CODE.EQ.37) GO TO 290
                IF (CODE.GT.39 .AND. CODE.LT.44) GO TO 100
                IF (CODE.EQ.44 .OR. CODE.EQ.45)  GO TO 140
                IF (CODE.EQ.46 .OR. CODE.EQ.47)  GO TO 150
                IF (CODE.EQ.48) GO TO 160
C-              IF (CODE.EQ.49) GO TO ???
                IF (CODE.EQ.50) GO TO 300
                IF (CODE.EQ.51) GO TO 310
                IF (CODE.EQ.52) GO TO 320
C      KEY-CODE ERROR?
                IF (CODE.EQ.99) GO TO 10
                   CALL MESAGE (81, RTRN)
                   GO TO 330
C      CALL KEY ROUTINE
   80           CALL ENTRY
                   GO TO 330
   90           CALL SIGN
                   GO TO 330
  100           CALL OPRATR
                   GO TO 330
  110           CALL LPAREN
                   GO TO 330
  120           CALL RPAREN
                   GO TO 330
  130           CALL EQUAL
                   GO TO 330
  140           CALL FUNCTN (1)
                   GO TO 330
  150           CALL FUNCTN (3)
                   GO TO 330
  160           CALL FUNCTN (4)
                   GO TO 330
  170           CALL RECALL (1)
                   GO TO 330
  180           CALL RECALL (2)
                   GO TO 330
  190           CALL CLEAR
                   GO TO 340
  200           CALL CLEARX (2)
                   GO TO 330
  210           CALL CORECT (2)
                   GO TO 330
  220           CALL DRPSTK
                   GO TO 330
  230           CALL STORE (1)
                   GO TO 330
  240           CALL FIXN
                   GO TO 330
  250           CALL SCIN
                   GO TO 330
  260           CALL IMEDEX
                   GO TO 330
  270           CALL EXCH
                   GO TO 330
  280           CALL SEMI
                   GO TO 330
  290           CALL COMMA
                   GO TO 330
  300           CALL SCR (1)
                   GO TO 330
  310           CALL FLAG (1)
                   GO TO 330
  320           CALL KYMODE (0)
C         GO BACK AND GET ANOTHER KEY-STROKE, MAYBE
  330           IF (KEY.LT.50) GO TO 70
  340        CONTINUE
          STOP
 1000     FORMAT (///' THE STANDARD CONTROL SETTINGS ARE:'   
     *              /'     PRODUCE "DISPLAY & REGISTERS" OUTPUT'
     *              /'     DISPLAY IN FIX MODE W/ FIX=2 & SCI=4'
     *              /'     USE A 7 LEVEL "STACK"'
     *             //' THESE ARE OKAY. ("T" OR "F")'/)
 1100     FORMAT (/' ENTER CODE FOR DESIRED OUTPUT:  0 = LONG STACK'
     *            /33X,'1 = SHORT STACK'/33X,'2 = DISPLAY ONLY'
     *            /33X,'3 = DISPLAY (& REGISTERS)'/)
 1200     FORMAT (/' THE STANDARD DISPLAY SETTINGS ARE WANTED.',
     *             ' ("T" OR "F")'/)
 1300     FORMAT (/' FIX MODE DISPLAY IS WANTED INITIALLY. ("T"/"F")'/)
 1400     FORMAT (/' ENTER NUMBER OF DECIMAL DIGITS DESIRED IN FIX'
     *            /' AND SCI MODES, RESPECTIVELY. ("N <SP> M")'/)
 1500     FORMAT (/' ENTER NUMBER OF STACK REGISTERS WANTED (MAX = 7)'/)
 1600     FORMAT (L1)
 1700     FORMAT (I)
 1800     FORMAT (2I)
 1900     FORMAT ('1 TEST NO.',I3/)
          END

      BLOCK DATA
C         DATE OF LAST CHANGE - 740310
          IMPLICIT INTEGER (A-Z)
          LOGICAL NEXT, STEP
          COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /OUTPT/ SKIP, DISPLY(32), PGMPTR
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
          DATA NEXT /.FALSE./, STEP /.FALSE./, UFLAG /11*0/, 
     *         LSTK /0/, PGMPTR /0/, W /17*0/, LFRC /0/, TEMP/0/,
     *         R(1,1),R(1,2),R(1,3),R(1,4),R(1,5),R(1,6),R(1,7),R(1,8),
     *         R(1,9),R(1,10),R(1,11),R(1,12),R(1,13),R(1,14),R(1,15),
     *         R(1,16),R(1,17) /15,3,1,4,1,5,9,2,6,5,3,5,9,0,15,0,0/
          END
      SUBROUTINE OUTPUT (PRINT)
C         DATE OF LAST CHANGE - 741118
          IMPLICIT INTEGER (A-Z)
          DIMENSION CHAR(56), STROKE(50), SIGN(7), ESN(7), REG(17),
     *              DISP(32), DISP2(16)
          LOGICAL EEX, DP, FIXFLG, STEP
          REAL*8 NAME(3)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     2           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     3           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     4           /OUTPT/ SKIP, DISPLY(32), PGMPTR
     5           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
          DATA CHAR( 1),CHAR( 2),CHAR( 3),CHAR( 4)/' 1',' 2',' 3',' 4'/,
     2         CHAR( 5),CHAR( 6),CHAR( 7),CHAR( 8)/' 5',' 6',' 7',' 8'/,
     3         CHAR( 9),CHAR(10),CHAR(11),CHAR(12)/' 9',' 0',' .',' E'/,
     4         CHAR(13),CHAR(14),CHAR(15),CHAR(16)/' -',' +','  ',' /'/,
     5         CHAR(17),CHAR(18),CHAR(19),CHAR(20)/' *',' (','**',' )'/,
     6         CHAR(21),CHAR(22),CHAR(23),CHAR(24)/' O',' =',' A','PI'/,
     7         CHAR(25),CHAR(26),CHAR(27),CHAR(28)/' R','CL','CD','CO'/,
     8         CHAR(29),CHAR(30),CHAR(31),CHAR(32)/'DS','LK','->','FX'/,
     9         CHAR(33),CHAR(34),CHAR(35),CHAR(36)/'SI','IX','XC',' ;'/,
     A         CHAR(37),CHAR(38),CHAR(39),CHAR(40)/' ,','LX','LY',' ='/,
     B         CHAR(41),CHAR(42),CHAR(43),CHAR(44)/' #',' >',' <','MG'/,
     C         CHAR(45),CHAR(46),CHAR(47),CHAR(48)/'AG','AB','SR','↑2'/,
     D         CHAR(49),CHAR(50),CHAR(51),CHAR(52)/' %','SC','FL','KL'/,
     E         CHAR(53),CHAR(54),CHAR(55),CHAR(56)/'XX','XX','XX','XX'/
          DATA NAME /'     A =', 'LAST X =','LAST Y ='/
C         VARIOUS VALUES OF "SKIP" GIVE:  -1 → CLEAR EXPRESSION
C                                          0 → LONG OUTPUT
C                                          1 → SHORT OUTPUT
C                                          2 → DISPLAY ONLY
C                                          3 → DISPLAY (& REGISTERS)
C
C     IF "PRINT" < "SKIP", SET "SKIP2" TO "PRINT"
          SKIP2=SKIP
          IF (PRINT.LT.SKIP) SKIP2=PRINT
          IF (SKIP2.GE.0) GO TO 20
             DO 10 I=1,50
   10           STROKE(I)=CHAR(15)
             RETURN
   20     DO 30 I=OLD,KEY
             J=EXPR(I)
             IF (J.EQ.0) J=10
   30        STROKE(I)=CHAR(J)
          TYPE 1000, (STROKE(I),I=1,KEY)
          OLD=KEY+1
          IF (SKIP2.EQ.2) GO TO 50
             K=SMAX
             IF (SKIP2.EQ.1) K=2
             DO 40 I=1,K
                J=X(I,1)
                IF (J.EQ.0) J=10
                SIGN(I)=CHAR(J)
                J=X(I,15)
                IF (J.EQ.0) J=10
                IF (J.EQ.12) J=42
   40           ESN(I)=CHAR(J)
   50     DO 60 I=1,32
             J=DISPLY(I)
             IF (J.EQ.0) J=10
   60        DISP(I)=CHAR(J)
          DO 70 I=1,16
             J=DSP(I)
             IF (J.EQ.0) J=10
   70        DISP2(I)=CHAR(J)
          IF (SKIP2.GT.1) GO TO 100
          IF (SKIP2.EQ.1) GO TO 90
          TYPE 1100, DP, L, EEX, M, FIXFLG, FIX, NEXT, SCI, STEP, ERROR
          TYPE 1200, SMAX, P(SMAX), SIGN(SMAX), (X(SMAX,N),N=2,14),
     2               ESN(SMAX), X(SMAX,16), X(SMAX,17), OP(SMAX)
          J=SMAX-3
          DO 80 I=1,J
             K=SMAX-I
   80        TYPE 1300, K, P(K), SIGN(K), (X(K,N),N=2,14), ESN(K),
     2                  X(K,16), X(K,17), OP(K)
   90     TYPE 1400, P(2), SIGN(2), (X(2,N), N=2,14), ESN(2), X(2,16),
     2               X(2,17), OP(2), P(1), SIGN(1), (X(1,N), N=2,14),
     3               ESN(1), X(1,16), X(1,17), OP(1)
          IF (SKIP2.EQ.0) TYPE 1500, DISP
  100     TYPE 1600, DISP2
          IF (SKIP2.EQ.2) RETURN
          DO 120 I=2,4
             IF (R(I,2).EQ.15) GO TO 120
                DO 110 J=1,17
                   K=R(I,J)
                   IF (K.EQ.0)  K=10
                   IF (K.EQ.12) K=42
  110              REG(J)=CHAR(K)
                TYPE 1700, NAME(I-1), (REG(N), N=1,17)
  120        CONTINUE
          DO 140 I=5,20
             IF (R(I,2).EQ.15) GO TO 140
                J=I-5
                DO 130 K=1,17
                   KK=R(I,K)
                   IF (KK.EQ.0)  KK=10
                   IF (KK.EQ.12) KK=42
  130              REG(K)=CHAR(KK)
                TYPE 1800, J, (REG(N), N=1,17)
  140        CONTINUE
          DO 150 I=1,11
             IF (UFLAG(I).EQ.1) GO TO 160
  150        CONTINUE
          RETURN
  160        TYPE 1900, UFLAG
             RETURN
 1000     FORMAT (/6X, 'EXPRESSION: ', 21A3, (/18X, 21A3))
 1100     FORMAT (//14X,'FLAGS:  DP    -',L2,20X,'INDICES:  L     -',
     2            I2/22X,'EEX   -',L2,30X,'M     -',I2/22X,'FIXFLG-',
     3            L2,30X,'FIX   -',I2/22X,'NEXT  -',L2,30X,'SCI   -',
     4            I2/22X,'STEP  -',L2,30X,'ERROR -',I2)
 1200     FORMAT (//14X, 'STACK:  S(', I2, ') -', 4X, I2, ' / ', A2,
     2            I2, ' .', 12I2, A2, 2I2, ' /', I3)
 1300     FORMAT (22X, 'S(', I2, ') -', 4X, I2, ' / ', A2, I2, ' .',
     2            12I2, A2, 2I2, ' /', I3)
 1400     FORMAT (/22X, 'S( 2) -', 4X, I2, ' / ', A2, I2, ' .', 12I2,
     2            A2, 2I2, ' /', I3/22X, 'S( 1) -', 4X, I2, ' / ',
     3            A2, I2, ' .', 12I2, A2, 2I2, ' /', I3/)
 1500     FORMAT (2(/14X, 'DISPLAY:', 9X, 16A2/)//)
 1600     FORMAT (/14X, 'DISPLAY:', 9X, 16A2///)
 1700     FORMAT (15X, A8, 1X, 2A2, ' .', 15A2)
 1800     FORMAT (14X, 'REG(', I2, ') =', 1X, 2A2, ' .', 15A2)
 1900     FORMAT (/14X, 'USER FLAGS:', 6X, I2, 2X, 5I2, 2X, 4I2, I4/)
          END
      SUBROUTINE CONTRL (START, PRINT)
C         DATE OF LAST CHANGE - 750318
          IMPLICIT INTEGER (A-Z)
          LOGICAL NEXT
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
             IF (NEXT) RETURN
             GO TO (1, 2, 3, 6, 6), START
C ** START 1 - UPDATE & FORMAT "DISPLAY"
    1        CALL UPDATE (1)
             GO TO 5
C ** START 2 - FGRMAT "DISPLAY"
    2        CALL UPDATE (2)
             GO TO 5
C ** START 3 - DASHES → "DISPLAY"
    3        DO 4 I=1,16
    4           DSP(I)=13
             DSP(8)=0
             DSP(9)=CODE/10
             DSP(10)=CODE-10*DSP(9)
    5        CALL KYMODE (1)
C ** START 4 - USE "DISPLAY" AS IS
    6        CALL OUTIN (PRINT)
             IF (CODE.NE.30) GO TO 7
                CALL LSTKEY
                IF (.NOT.NEXT) GO TO 6
                   NEXT=.FALSE.
    7        RETURN
             END








      SUBROUTINE OUTIN (PRINT)
C         DATE OF LAST CHANGE - 750312
          IMPLICIT INTEGER (A-Z)
          COMMON /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /OUTPT/ SKIP, DISPLY(32), PGMPTR
             CALL OUTPUT (PRINT)
             LSTK=CODE
    1        TYPE 4
             ACCEPT 5, CODE
             IF (CODE.NE.100) GO TO 2
                CALL OUTPUT (0)
                GO TO 1
    2        KEY=KEY+1
             IF (KEY.LT.51) GO TO 3
                KEY=1
                OLD=1
    3        EXPR(KEY)=CODE
             IF (CODE.EQ.10) CODE=0
             PGMPTR=PGMPTR+1
             RETURN
    4        FORMAT (' ?'/)
    5        FORMAT (I)
             END
      SUBROUTINE UPDATE (START)
C         DATE OF LAST CHANGE - 750124
C         PURPOSE:  1  - COPY X(1) TO D USING CURRENT DISPLAY FORMAT
C                        (W CONTAINS X(1) ROUNDED TO RIGHT NO. OF DIGITS)
C                   2A - COPY D TO DSP INSERTING SPACING BLANKS
C                   2B - COPY DSP TO DSP RIGHT JUSTIFYING MANTISSA
          IMPLICIT INTEGER (A-Z)
          LOGICAL FIXFLG, STEP
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /OUTPT/ SKIP, DISPLY(32), PGMPTR
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             IF (START.EQ.2) GO TO 19
C ** START1 - UPDATE DISPLAY CONTENTS 
             D(1)=X(1,1)
             IF (OP(1).GE.70) GO TO 19
             IF (.NOT.FIXFLG) GO TO 9
C        DISPLAY IN "FIX" FORMAT, IF POSSIBLE
                IF (X(1,16).GT.0) GO TO 9
                   N=FIX
                   K=FIX+1
                   IF (X(1,15).NE.13) GO TO 1
                      K=K-X(1,17)
                      IF (K.LT.0) GO TO 4
                         GO TO 2
    1              K=K+X(1,17)
                   IF (K.LE.10) GO TO 2
                      N=9-X(1,17)
                      K=10
    2              CALL ROUND
                   IF (W(16).GT.0) GO TO 9
                      K=W(17)+1
                      IF (W(15).EQ.13) GO TO 5
                         DO 3 I=1,K
    3                       D(I+1)=W(I+1)
                         J=K
                         K=K+1
                         KMAX=K+N
                         D(K+1)=11
                         GO TO 7
    4                       K=N+2
    5                 D(2)=0
                      D(3)=11
                      DO 6 I=3,K
    6                    D(I+1)=0
                      J=0
                      KMAX=N+2
    7                 K=K+1
                      IF (K.GT.KMAX) GO TO 8
                         J=J+1
                         D(K+1)=W(J+1)
                         GO TO 7
    8                 KMAX=15
                      GO TO 15
C        DISPLAY IN "SCI" FORMAT
    9        IF (.NOT.STEP) GO TO 10
                IF (SCI.LT.7) GO TO 10
                   N=6
                   GO TO 11
   10        N=SCI
   11        K=N
             CALL ROUND
             D(2)=W(2)
             D(3)=11
             IF (W(15).NE.12) GO TO 12
                IF (.NOT.STEP) N=10
                IF (STEP) N=6
                W(15)=15
   12        DO 13 I=2,N
   13           D(I+2)=W(I+1)
             D(13)=12
             DO 14 I=13,15
   14           D(I+1)=W(I+2)
             K=N+2
             IF (K.GT.11) GO TO 17
                KMAX=11
   15           DO 16 I=K,KMAX
   16              D(I+1)=15
C        X(0) ≡ 0 ?
   17        IF (X(1,2).NE.0) GO TO 19
                DO 18 I=2,12
                   IF (D(I).NE.11) GO TO 18
                      D(I)=15
                      GO TO 19
   18              CONTINUE
C ** START 2 - FORMAT DISPLAY CONTENTS
   19        DO 20 II=1,16
                DSP(II)=15
   20           DISPLY(II)=D(II)
             DSP(1)=D(1)
C        DISPLAY FUNCTION?
             IF (OP(1).LT.70) GO TO 21
                DSP(3)=11
                DSP(4)=0
                DSP(5)=X(1,2)/10
                DSP(6)=X(1,2)-10*DSP(5)
                DSP(7)=11
                IF (X(1,3).EQ.X(1,4)) GO TO 35
                   DSP(8)=X(1,3)
                   DSP(9)=13
                   DSP(10)=X(1,4)
                   DSP(11)=11
                   GO TO 35
C        X(0) = "NULL" ?
   21        IF (X(1,2).NE.15) GO TO 22
                IF (M.EQ.1) GO TO 35
C        DISPLAY PROGRAM POINTER?
   22        IF (STEP) GO TO 32
C        COPY D TO DSP, INSERTING SPACING BLANKS
             I=1
             K=0
             J=0
             N=0
   23        N=N+1
             IF (D(N+1).GT.9) GO TO 24
                K=K+1
                IF (K.NE.3) GO TO 23
                   K=0
                   J=J+1
                   GO TO 23
   24        N=1
   25        IF (K.EQ.0) GO TO 27
                IF (D(N+1).GT.11) GO TO 30
   26              IF (I.GT.15) GO TO 32
                      DSP(I+1)=D(N+1)
                      I=I+1
                      N=N+1
                      K=K-1
                      GO TO 25
   27        IF (J.EQ.0) GO TO 29
                IF (I.EQ.1) GO TO 28
                   DSP(I+1)=15
                   I=I+1
   28           K=3
                J=J-1
                GO TO 25
   29        IF (D(N+1).EQ.12) GO TO 31
                K=4
                J=10
                GO TO 26
   30        IF (D(13).NE.12) GO TO 35
   31           K=13
                IF (I.LT.13) GO TO 33
   32              K=1
   33           DO 34 II=K,16
   34              DSP(II)=D(II)
             IF (DSP(13).NE.12) GO TO 35
                IF (DSP(15).NE.0) GO TO 35
                   DSP(15)=DSP(16)
                   DSP(16)=15
C
   35        DO 36 II=1,16
   36           DISPLY(II+16)=DSP(II)
C
C        COPY DSP TO DSP, RIGHT JUSTIFYING MANTISSA
             K=11
   37        IF (DSP(K+1).NE.15) GO TO 38
                K=K-1
                IF (K.GE.0) GO TO 37
                   RETURN
   38        IF (.NOT.STEP) GO TO 40
                IF (DSP(13).NE.12) GO TO 39
                   N=11
                   GO TO 41
   39           N=15
                GO TO 41
   40        IF (K.GT.9) RETURN
                N=10
   41           DSP(N+1)=DSP(K+1)
                N=N-1
                IF (K.EQ.0) GO TO 42
                   K=K-1
                   GO TO 41
   42           N=N+1
                DO 43 I=1,N
   43              DSP(I)=15
                RETURN
             END
      SUBROUTINE MESAGE (ERR, RTRN)
C         DATE OF LAST CHANGE - 750315
          IMPLICIT INTEGER (A-Z)
          LOGICAL NEXT, RUNPGM
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
          DATA RUNPGM /.FALSE./
             RTRN=0
             GO TO (1, 1, 2, 1, 3, 3, 3), ERR
C       ERRORS 1, 2, 4, 8, ...
    1        ERROR=ERR
             TEMP=2
             GO TO 4
C       ERROR 3
    2        IF (CODE.EQ.28) GO TO 16
             IF (CODE.EQ.27) GO TO 16
             IF (CODE.EQ.26) GO TO 15
                ERROR=ERR
                TEMP=0
                GO TO 4
C       ERRORS 5, 6, & 7
    3        ERROR=ERR
             TEMP=1
             UFLAG(11)=1
             IF (UFLAG(10).EQ.0) GO TO 4
                ERROR=0
                RETURN
C       PROCESS ERROR
    4        NEXT=.FALSE.
             DO 5 I=1,16
    5           DSP(I)=13
C       KEYBOARD ERROR MESSAGE → "DSP"
             DO 6 I=4,13
    6           DSP(I)=15
             DSP(5)=12
             DO 7 I=6,9
    7           DSP(I)=25
             DSP(8)=21
             DSP(11)=ERROR/10
             DSP(12)=ERROR-10*DSP(11)
             IF (ERROR.NE.7) GO TO 8
                IF (X(1,2).EQ.0) GO TO 8
                   DSP(13)=21
                   DSP(14)=15
C       MODIFY MESSAGE FOR PROGRAM ERROR, MAYBE
    8        IF (RUNPGM) GO TO 9
                IF (.NOT.STEP) GO TO 11
    9              J=12
                   K=15
   10              DSP(K+1)=DSP(J+1)
                      J=J-1
                      K=K-1
                      IF (J.GT.1) GO TO 10
                   DSP(5)=15
                   CALL KYMODE (2)
   11        ERROR=0
             HOLD=CODE
C       LOOK FOR AND ACT ACCORDING TO USER'S RESPONSE
   12        CALL CONTRL (5, 2)
             IF (TEMP.NE.0) GO TO 13
                IF (CODE.EQ.28) RETURN
                GO TO 14
   13        IF (TEMP.NE.1) GO TO 14
                IF (CODE.NE.27) GO TO 14
                   CODE=HOLD
                   RETURN
   14        IF (CODE.EQ.28) GO TO 16
                IF (CODE.EQ.27) GO TO 16
                   IF (CODE.EQ.26) GO TO 15
                      GO TO 12
   15              NEXT=.TRUE.
   16        RTRN=1
             RETURN
             END



      SUBROUTINE RESET
C         DATE OF LAST CHANGE - 741024
          IMPLICIT INTEGER (A-Z)
          LOGICAL EEX, DP
          COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
             L=1
             M=1
             DP=.FALSE.
             EEX=.FALSE.
             RETURN
             END



      SUBROUTINE FIXN
C         DATE OF LAST CHANGE - 741108
          IMPLICIT INTEGER (A-Z)
          LOGICAL FIXFLG
          COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
             FIXFLG=.TRUE.
             CALL NUMBER (1, RTRN)
                IF (RTRN.EQ.1) GO TO 1
             FIX=W(2)
    1        RETURN
             END



      SUBROUTINE SCIN
C         DATE OF LAST CHANGE - 741108
          IMPLICIT INTEGER (A-Z)
          LOGICAL FIXFLG
          COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
             FIXFLG=.FALSE.
             CALL NUMBER (1, RTRN)
                IF (RTRN.EQ.1) GO TO 1
             SCI=W(2)+1
    1        RETURN
             END
      SUBROUTINE CLEAR
C         DATE OF LAST CHANGE - 740920
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             CALL CLEARX (1)
             DO 1 I=2,SMAX
                J=I-1
                P(I)=P(J)
                OP(I)=OP(J)
                DO 1 K=1,17
    1              X(I,K)=X(J,K)
             RETURN
             END














      SUBROUTINE LPAREN
C         DATE OF LAST CHANGE - 740715
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             IF (P(1).NE.7) GO TO 1
                CALL MESAGE (8, RTRN)
                RETURN
    1        IF (X(1,2).NE.15) GO TO 2
                IF (X(1,1).NE.13) GO TO 5
                   CALL TESTUP (RTRN)
                      IF (RTRN.EQ.1) GO TO 8
                   X(1,2)=1
                   GO TO 3
    2        IF (OP(1).NE.0) GO TO 6
                CALL TESTUP (RTRN)
                   IF (RTRN.EQ.1) GO TO 8
    3           OP(1)=50
                CALL COLAPS (RTRN)
                   IF (RTRN.EQ.1) GO TO 8
    4           CALL ENTRUP
    5           P(1)=P(1)+1
                RETURN
    6        IF (OP(1).NE.1) GO TO 7
                RN=-2
                CALL TRANS (.TRUE.)
                CALL CLEARX (2)
                GO TO 5
    7        IF (X(SMAX,2).EQ.15) GO TO 4
                CALL MESAGE (8, RTRN)
    8           RETURN
             END
      SUBROUTINE RPAREN
C         DATE OF LAST CHANGE - 750212
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             IF (OP(1).LT.2) GO TO 2
    1           CALL MESAGE (1, RTRN)
                RETURN
    2        DO 3 I=1,SMAX
                IF (P(I).NE.0) GO TO 4
    3              CONTINUE
                   CALL MESAGE (2, RTRN)
                   RETURN
    4        IF (OP(I+1).LT.72) GO TO 6
                IF (X(I+1,3).LE.I) GO TO 5
                   CALL MESAGE (9, RTRN)
                   RETURN
    5           IF (P(I).NE.1) GO TO 6
                   IF (I.EQ.1) GO TO 6
    6        IF (P(1).NE.0) GO TO 9
                IF (X(1,2).EQ.15) GO TO 1
                IF (OP(2).NE.10) GO TO 8
                   DO 7 I=3,SMAX
                      IF (OP(I).LT.72) GO TO 7
                         PTR=I
                         CALL EXECUT (1, RTRN)
                            IF (RTRN.EQ.1) GO TO 13
                         RETURN
    7                 CONTINUE
                   GO TO 1
    8           PTR=2
                CALL EXECUT (1, RTRN)
                   IF (RTRN.EQ.1) GO TO 13
                GO TO 6
    9        P(1)=P(1)-1
             IF (P(1).NE.0) RETURN
                IF (X(1,2).NE.15) GO TO 12
                   IF (OP(2).NE.50) RETURN
C                     HERE TO STATEMENT 12 FIXES UP "-()"
                      OP(2)=0
                      IF (X(2,2).NE.1) GO TO 11
                         DO 10 I=3,14
                            IF (X(2,I).NE.0) GO TO 11
   10                       CONTINUE
                         IF (X(2,16).NE.0) GO TO 11
                         IF (X(2,17).NE.0) GO TO 11
                            X(2,2)=15
   11                 CALL DROP (1)
                      RETURN
   12           IF (OP(2).LT.70) RETURN
                   PTR=2
                   CALL EXECUT (2, RTRN)
   13              RETURN
             END
      SUBROUTINE EQUAL
C         DATE OF LAST CHANGE - 741024
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             IF (X(1,2).EQ.15) GO TO 1
                IF (OP(1).LT.10) GO TO 2
    1              CALL MESAGE (1, RTRN)
                   RETURN
    2        DO 3 I=1,SMAX
                IF (P(I).EQ.0) GO TO 3
                   CALL MESAGE (2, RTRN)
                   RETURN
    3           CONTINUE
    4        IF (OP(2).EQ.0) GO TO 5
                PTR=2
                CALL EXECUT (1, RTRN)
                   IF (RTRN.EQ.1) GO TO 6
                GO TO 4
    5        OP(1)=1
C-           RN="RESULT REGISTER NUMBER"
C-           CALL TRANS (.TRUE.)
    6        RETURN
             END



      SUBROUTINE EXCH
C         DATE OF LAST CHANGE - 750416
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             DO 1 I=1,17
    1           W(I)=X(1,I)
             DO 2 I=1,17
    2           X(1,I)=X(2,I)
             DO 3 I=1,17
    3           X(2,I)=W(I)
             IF (OP(1).GT.60) GO TO 4
                IF (OP(2).LT.70) GO TO 5
    4        W(1)=OP(1)
             OP(1)=OP(2)
             OP(2)=W(1)
    5        RETURN
             END



      SUBROUTINE DRPSTK
C         DATE OF LAST CHANGE - 750220
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
             IF (OP(1).EQ.0) GO TO 2
    1           CALL MESAGE (1, RTRN)
                RETURN
    2        IF (X(1,2).NE.15) GO TO 1
                IF (P(1).NE.0) GO TO 1
                   CALL DROP (1)
                   RETURN
              END
      SUBROUTINE SIGN
C         DATE OF LAST CHANGE - 750416
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
             IF (OP(1).NE.0) GO TO 2
                IF (X(1,2).EQ.15) GO TO 5
    1              OP(1)=CODE+17
                   CALL COLAPS (RTRN)
                      IF (RTRN.EQ.1) GO TO 6
                   RETURN
    2        IF (OP(1).EQ.1) GO TO 1
                IF (OP(1).LT.72) GO TO 3
                   CALL MESAGE (1, RTRN)
                   RTRN=1
                   RETURN
    3           IF (X(SMAX,2).EQ.15) GO TO 4
                   CALL MESAGE (8, RTRN)
                   RETURN
    4        CALL ENTRUP
    5        IF (CODE.NE.13) GO TO 6
                IF (X(1,1).EQ.13) D(1)=15
                IF (X(1,1).NE.13) D(1)=13
                X(1,1)=D(1)
    6        RETURN
             END
















      SUBROUTINE OPRATR
C         DATE OF LAST CHANGE - 740925
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
             IF (X(1,2).EQ.15) GO TO 1
                IF (OP(1).LT.10) GO TO 2
    1              CALL MESAGE (1, RTRN)
                   RETURN
    2        IF (CODE.LT.19) OP(1)=CODE+24
             IF (CODE.EQ.19) OP(1)=60
             IF (CODE.EQ.36) OP(1)=10
             IF (CODE.EQ.37) OP(1)=10
             IF (CODE.GT.37) OP(1)=CODE-20
             CALL COLAPS (RTRN)
             RETURN
             END
      SUBROUTINE FUNCTN (START)
C         DATE OF LAST CHANGE - 750416
          IMPLICIT INTEGER (A-Z)
          LOGICAL NEXT, TEMPF
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             GO TO ( 1, 2, 3, 11, 15), START
C ** START 1 - MULTIPLE VARIABLE FUNCTION
    1        PTR=2
             TEMP=2
C ** START 2 - VARIABLE ARGUMENT M.V.F. (PTR & TEMP SET)
    2        NEXT=.TRUE.
             GO TO 4
C ** START 3 - SINGLE VARIABLE FUNCTION
    3        PTR=1
             TEMP=1
             NEXT =.FALSE.
    4        TEMPF=.FALSE.
    5        CALL SETUP (RTRN)
                IF (RTRN.EQ.1) GO TO 14
             X(1,2)=CODE
             X(1,3)=PTR
             X(1,4)=TEMP
             D(1)=15
             IF (TEMPF) GO TO 16
                IF (NEXT) GO TO 6
                   OP(1)=70
                   RETURN
C         CONTINUE MULTIPLE VARIABLE FUNCTION
    6           OP(1)=72
                NEXT=.FALSE.
                RETURN
C ** START 4 - "IMMEDIATE" SINGLE VARIABLE FUNCTION
   11        IF (X(1,2).EQ.15) GO TO 12
             IF (OP(1).LT.2) GO TO 13
   12           CALL MESAGE (1, RTRN)
                RETURN
   13        OP(1)=70
             CALL COLAPS (RTRN)
                IF (RTRN.EQ.1) GO TO 14
             OP(1)=0
             PTR=0
             CALL EXECUT (2, RTRN)
   14        RETURN
C ** START 5 - "LANGUAGE FUNCTION"
   15        TEMPF=.TRUE.
             GO TO 5
   16           IF (TEMP.EQ.1) GO TO 17
                   OP(1)=73
                   X(1,5)=OPCD
                   GO TO 18
   17           OP(1)=71
   18           CODE=18
                IF (OP(2).NE.50) GO TO 19
                   IF (P(1).EQ.0) OP(2)=0
   19           CALL LPAREN
                RETURN
             END
      SUBROUTINE SEMI
C         DATE OF LAST CHANGE - 750104
          LOGICAL IF
          DATA IF /.FALSE./
             IF (.NOT.IF) GO TO 1
C      TREAT AS STRING SEPARATOR FOR "IF"
                IF=.FALSE.
                RETURN
C      TREAT AS GENERAL ARGUMENT SEPARATOR 
    1        CALL OPRATR
             RETURN
             END

























      SUBROUTINE COMMA
C         DATE OF LAST CHANGE - 750220
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
C      TREAT AS ARGUMENT SEPARATOR FOR "MVO"
             K=0
             DO 2 I=2,SMAX
                IF (OP(I).LT.72) GO TO 1
                   IF (P(I-1).EQ.1) GO TO 3
                      CALL MESAGE (2, RTRN)
                      RETURN
    1           IF (OP(I).EQ.10) K=K+1
    2           CONTINUE
             GO TO 5
    3           IF (X(I,4).GT.K+1) GO TO 4
                   CALL MESAGE (10, RTRN)
                   RETURN
    4           CALL OPRATR
                RETURN
C      TREAT AS "NO-OP"
    5        RETURN
             END
      SUBROUTINE IMEDEX
C         DATE OF LAST CHANGE - 750104
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
C-        NOTE:  FOLLOWING 5 LINES ARE BASED ON MVO'S CALLING "LPAREN"
C-           IF (OP(2).LT.72) GO TO 2
C-              IF (OP(1).NE.0) GO TO 3
C-              CALL DROP (1)
C-        NOTE:  FOLLOWING LINE NOT USED WHEN MVO'S CALL "LPAREN"
             IF (OP(1).LT.72) GO TO 2
                OP(3)=OP(1)
                OP(1)=0
                DO 1 I=1,17
                   TEMP=X(1,I)
                   X(1,I)=X(2,I)
                   X(2,I)=X(3,I)
    1              X(3,I)=TEMP
                PTR=3
                GO TO 7
    2        IF (X(1,2).EQ.15) GO TO 3
             IF (X(2,2).EQ.15) GO TO 3
             IF (P(1).EQ.0) GO TO 4
    3           CALL MESAGE (1, RTRN)
                RETURN
    4        IF (OP(1).LT.20) GO TO 6
                IF (OP(2).LT.20) GO TO 5
                   IF (OP(2).NE.50) GO TO 3
    5           OP(2)=OP(1)
                OP(1)=0
                IF (OP(2).EQ.70) CALL EXCH
                PTR=2
                GO TO 7
    6        IF (OP(2).LT.20) GO TO 3
    7           CALL EXECUT (1, RTRN)
                RETURN
             END
      SUBROUTINE COLAPS (RTRN)
C         DATE OF LAST CHANGE - 740809
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             RTRN=0
    1        IF (P(1).NE.0) RETURN
             IF (OP(2).EQ.10) RETURN
             IF (OP(1)/10 .GT. OP(2)/10) RETURN
                PTR=2
                CALL EXECUT (1, RTRN)
                   IF (RTRN.EQ.1) GO TO 2
                GO TO 1
    2        RTRN=1
             RETURN
             END
























      SUBROUTINE EXECUT (START, RTRN)
C         DATE OF LAST CHANGE - 741218
          IMPLICIT INTEGER (A-Z)
          DIMENSION A(2,17)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
          DATA A/34*0/
             RTRN=0
             IF (START.EQ.2) GO TO 5
C ** START 1 - BINARY OPERATORS & MULTIPLE ARGUMENT FUNCTIONS
             IF (OP(2).EQ.70) GO TO 7
C       SAVE X(2,N) IN "LST X" & X(1,N) IN "LST Y"
             DO 1 I=1,2
C?              IF (X(I,2).EQ.15) X(I,2)=0
                DO 1 N=1,17
                   R(4,N)=X(1,N)
                   R(3,N)=X(2,N)
    1              A(I,N)=X(I,N)
             IF (OP(PTR).GT.71) GO TO 3
C       EXECUTE BINARY FUNCTION 
                OPCD=OP(2)
                CALL COMBIN (A, 2)
                DO 2 N=1,17
    2              X(1,N)=A(1,N)
                GO TO 13
C       EXECUTE "MVO"
    3        IF (OP(PTR).EQ.73) GO TO 6
                OPCD=OP(PTR)+X(PTR,2)
                CALL COMBIN (A, 2)
                J=PTR+1
                DO 4 I=J,6
                   IF (OP(I).EQ.72) GO TO 11
    4              CONTINUE
                GO TO 11
C ** START 2 - SINGLE ARGUMENT FUNCTIONS
    5        IF (OP(2).LT.71) GO TO 7
    6           CALL ARGMNT (2)
                RETURN
C       SAVE X(1,N) IN "LST X"; EXECUTE "SVO"
C?  7        IF (X(1,2).EQ.15) X(1,2)=0
    7        RN=-2
             CALL TRANS (.TRUE.)
             DO 8 N=1,17
    8           A(1,N)=X(1,N)
             IF (PTR.NE.0) GO TO 9
                OPCD=70+CODE
                GO TO 10
    9        OPCD=OP(2)+X(2,2)
   10        CALL COMBIN (A, 1)
   11        DO 12 N=1,17
   12           X(1,N)=A(1,N)
             IF (X(1,2).EQ.0) X(1,1)=15
             IF (PTR.EQ.0) RETURN
C       CONSIDER SIGN PRECEEDING FUNCTION
             IF (X(PTR,1).NE.13) GO TO 13
                SIGN=X(1,1)
                IF (SIGN.EQ.13) X(1,1)=15
                IF (SIGN.NE.13) X(1,1)=13
   13        IF (X(1,2).EQ.0) X(1,1)=15
C       DROP STACK APPROPRIATE AMOUNT
             CALL DROP (2)
                IF (PTR.LT.3) GO TO 14
                   PTR=PTR-1
                   GO TO 13
   14        IF (ERROR.EQ.0) GO TO 15
                CALL MESAGE (ERROR, RTRN)
   15        RETURN 
             END
      SUBROUTINE COMBIN (A, NARGS)
C         DATE OF LAST CHANGE - 741215
C         PURPOSE:  EXECUTE- "A(2,N) OPCD A(1,N) → A(1,N)"
C                            "SVO [A(1,N)] → A(1,N)"
C                            "[A(2,N)] SVO → A(1,N)"
C                            "MVO [A(2,N); A(1,N)] → A(1,N)"
          IMPLICIT INTEGER (A-Z)
          REAL*8 RX(2), RX1, DLOG10, DABS, DLOG, DEXP, DSQRT, E
          DIMENSION A(2,17)
          COMMON /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
C  (1) CONVERT A(I,N) TO RX(I)
             DO 2 I=1,2
                RX(I)=A(I,14)
                DO 1 J=1,12
                   KK=14-J
    1              RX(I)=0.1*RX(I)+A(I,KK)
                IF (A(I,1).EQ.13) RX(I)=-RX(I)
                J=10*A(I,16)+A(I,17)
                IF (J.GT.20) J=20
                IF (A(I,15).EQ.13) J=-J
    2           RX(I)=RX(I)*10.0**J
             RX1=RX(1)
C  (2) NOW EXECUTE RX(2), OPCD, RX(1) -> RX(1)=RX1
             IF (OPCD.GT.60) GO TO 15
             IF (OPCD.EQ.60) GO TO 14
             IF (OPCD.GT.31) GO TO 9
             IF (OPCD.GT.23) GO TO 8
C         RELATIONALS
             VALUE=0
             GO TO (3, 4, 5, 6), OPCD-19
    3           IF (RX(2) .EQ. RX1) VALUE=1
                   GO TO 7
    4           IF (RX(2) .NE. RX1) VALUE=1
                   GO TO 7
    5           IF (RX(2) .GT. RX1) VALUE=1
                   GO TO 7
    6           IF (RX(2) .LT. RX1) VALUE=1
    7        RX1=VALUE
             GO TO 23
C         ADDITION/SUBTRACTION
    8        IF (OPCD.EQ.30) RX1=-RX1
             RX1=RX(2)+RX1
             GO TO 23
C         MULTIPLICATION/DIVISION
    9        IF (OPCD.EQ.40)  GO TO 10
                RX1=RX(2)*RX1
                GO TO 23
   10        IF (DABS(RX1).GT.1.0E-20) GO TO 13
   11           ERROR=6
   12           KK=9
C-              "EXP OF A"="+ OVERFLOW"
                J=12
                GO TO 29
   13        RX1=RX(2)/RX1
             GO TO 23
C         EXPONENTIATION
   14        IF (RX(2).LE.0.0) GO TO 11
                RX1=RX1*DLOG(RX(2))
                IF (DABS(RX1).GT.85.) ERROR=7
                IF (DABS(RX1).GT.85.) RX1=85.*RX1/DABS(RX1)
                RX1=DEXP(RX1)
                GO TO 23
   15        IF (NARGS.NE.1) GO TO 19
C         SINGLE VARIABLE FUNCTIONS
                GO TO (16, 17, 18), OPCD-115
   16              RX1=DABS(RX1)
                      GO TO 23
   17              IF (RX1.LT.0) ERROR=6
                   IF (RX1.LT.0) RX1=-RX1
                   RX1=DSQRT(RX1)
                      GO TO 23
   18              RX1=RX1*RX1
                      GO TO 23
C         MULTIPLE VARIABLE FUNCTIONS
   19           GO TO (20, 21), OPCD-115
   20              RX1=DSQRT(RX1*RX1+RX(2)*RX(2))
                      GO TO 23
   21              IF (DABS(RX(2)).GT.1.E-20) GO TO 22
                      RX1=90.
                      GO TO 23
   22              RX1=DATAN(RX1/RX(2))*57.29577951D0
C  (3) EXTRACT EXPONENT, -> A(1,15), ..., A(1,17)
   23        IF (RX1.EQ.0.0) GO TO 24
                E=DLOG10(DABS(RX1))+.00001
                GO TO 25
   24        KK=0
             GO TO 27
   25           IF (E.GE.0.0) GO TO 26
                   KK=-E+1
                   RX1=RX1*10.0**KK
                   A(1,15)=13
                   GO TO 28
   26           KK=E
                RX1=RX1/10.0**KK
   27        A(1,15)=15
   28        A(1,16)=KK/10
             A(1,17)=KK-10*A(1,16)
C  (4) CHECK FOR OVER/UNDER-FLOW
             IF (A(1,16).LT.10) GO TO 31
                ERROR=7
                IF (A(1,15).NE.13) GO TO 12
                   KK=0
                   A(1,1)=15
C-                 "EXP OF A"="+"
                   J=15
   29              A(1,1)=A(2,1)
                   DO 30 I=2,17
   30                 A(1,I)=KK
                   A(1,15)=J
                   GO TO 35
C  (5) CONVERT RX1=RX(1) TO A(1,N), N=1, ..., 14
   31        IF (RX1.GE.0.0) GO TO 32
                A(1,1)=13
                RX1=-RX1
                GO TO 33
   32        A(1,1)=15
   33        A(1,2)=RX1
             DO 34 I=3,14
                J=I-1
                RX1=10.*(RX1-A(1,J))
   34           A(1,I)=RX1
   35        RETURN
             END
      SUBROUTINE ENTRY
C         DATE OF LAST CHANGE - 750125
          IMPLICIT INTEGER (A-Z)
          LOGICAL EEX
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
             CALL SETUP (RTRN)
                IF (RTRN.EQ.1) GO TO 10
             DO 1 I=2,16
    1           D(I)=15
    2        IF (CODE.GT.9) GO TO 3
                CALL DIGIT
                GO TO 11
    3        IF (CODE.NE.11) GO TO 4
                CALL DECPT
                GO TO 11
    4        IF (CODE.NE.12) GO TO 5
                CALL ENTEXP
                IF (ERROR.NE.0) RETURN
                GO TO 11
    5        IF (CODE.NE.28) GO TO 6
                START=1
                CALL CORECT (START)
                   IF (START.NE.1) GO TO 10
                GO TO 11
    6        IF (.NOT.EEX.OR.(CODE.NE.13.AND.CODE.NE.14)) GO TO 7
                IF (D(15).NE.0) GO TO 7
                   IF (D(16).NE.15) GO TO 7
                      D(14)=CODE
                      GO TO 11
    7        IF (X(1,2).EQ.15) GO TO 8
                IF (D(13).NE.12) GO TO 9
                   CALL ADEXPD (RTRN)
                      IF (RTRN.EQ.1) GO TO 10
                   GO TO 9
    8        X(1,2)=0
    9        CALL RESET
             NEXT=.TRUE.
   10        RETURN
C        FORMAT "DISPLAY" & GET NEXT KEYSTROKE
   11        CALL CONTRL (2, 2)
             GO TO 2
                END
      SUBROUTINE DIGIT
C         DATE OF LAST CHANGE - 750130
          IMPLICIT INTEGER (A-Z)
          LOGICAL EEX, DP
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
             IF (.NOT.EEX) GO TO 1
                D(15)=D(16)
                IF (D(15).EQ.15) D(15)=0
                D(16)=CODE
                RETURN
    1        IF (M.GT.14) RETURN
             IF (DP) GO TO 2
                IF (M.EQ.14) RETURN
    2        M=M+1
             D(M)=CODE
             IF (L.GT.13) RETURN
             IF (DP) GO TO 3
                IF (L.EQ.1) GO TO 4
                   CALL EXPON (X(1,15),X(1,16),X(1,17),1)
                   GO TO 5
    3        IF (L.NE.1) GO TO 5
                CALL EXPON (X(1,15),X(1,16),X(1,17),-1)
    4           IF (CODE.EQ.0) RETURN
    5        L=L+1
             X(1,L)=CODE
             RETURN
             END













      SUBROUTINE DECPT
C         DATE OF LAST CHANGE - 741004
          IMPLICIT INTEGER (A-Z)
          LOGICAL EEX, DP
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
             IF (.NOT.EEX) GO TO 1
                EEX=.FALSE.
                RETURN
    1        IF (DP) RETURN
             DP=.TRUE.
             IF (M.GT.13) RETURN
                M=M+1
                D(M)=11
             RETURN
             END
      SUBROUTINE ENTEXP
C         DATE OF LAST CHANGE - 750125
          IMPLICIT INTEGER (A-Z)
          LOGICAL EEX, DP
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
             IF (.NOT.EEX) GO TO 2
                CALL TESTUP (RTRN)
                   IF (RTRN.EQ.1) GO TO 4
                IF (D(13).NE.12) GO TO 1
                   CALL ADEXPD (RTRN)
                      IF (RTRN.EQ.1) GO TO 4
    1           OP(1)=50
                CALL COLAPS (RTRN)
                   IF (RTRN.EQ.1) GO TO 4
                CALL ENTRUP
                D(1)=15
                X(1,1)=15
                GO TO 3
    2        IF (X(1,16).NE.0) RETURN
    3           D(13)=12
                D(14)=15
                D(15)=0
                D(16)=15
                EEX=.TRUE.
                IF (M.NE.1) RETURN
                   D(2)=1
                   D(3)=11
                   X(1,2)=1
                   M=3
                   L=2
                   DP=.TRUE.
    4              RETURN
             END






      SUBROUTINE CLEARX (START)
C         DATE OF LAST BHANGE - 750104
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             GO TO (1, 2, 3), START
C ** START 1 - CLEAR S(1)
    1        P(1)=0
C ** START 2 - "CLEAR X"
    2        OP(1)=0
C ** START 3 - CLEAR X(1)
    3        D(1)=15
             X(1,1)=15
             X(1,2)=15
             DO 4 I=3,17
    4           X(1,I)=0
             X(1,15)=15
             CALL RESET
             RETURN
             END
      SUBROUTINE CORECT (START)
C         DATE OF LAST CHANGE - 750314
          IMPLICIT INTEGER (A-Z)
          LOGICAL EEX, DP
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
             IF (START.EQ.2) GO TO 11
C ** START 1 - ENTRY POINT FROM "ENTRY"
             IF (.NOT.EEX) GO TO 2
                EEX=.FALSE.
                DO 1 I=13,16
    1              D(I)=15
                RETURN
    2        IF (M.GT.2) GO TO 4
                IF (M.EQ.1) GO TO 3
                IF (X(1,1).EQ.13) GO TO 4
    3              CALL CLEARX (3)
                   START=2
                   RETURN
    4        IF (.NOT.DP) GO TO 6
                IF (D(M).NE.11) GO TO 5
                   DP=.FALSE.
                   GO TO 10
    5           IF (L.GT.2) GO TO 7
                   CALL EXPON (X(1,15),X(1,16),X(1,17),1)
                   IF (L.EQ.2) GO TO 8
                      GO TO 10
    6        IF (L.EQ.1) GO TO 10
                IF (L.EQ.2) GO TO 8
                   CALL EXPON (X(1,15),X(1,16),X(1,17),-1)
    7              X(1,L)=0
                   GO TO 9
    8           X(1,L)=15
    9           L=L-1
   10        D(M)=15
             M=M-1
             RETURN
C ** START 2 - ENTRY POINT FROM "LOOK-UP"
   11        IF (OP(1).EQ.0) GO TO 13
                IF (OP(1).LT.70) GO TO 12
                   CALL CLEARX (2)
                   RETURN
   12           OP(1)=0
                RETURN
   13        IF (X(1,2).EQ.15) GO TO 15
   14           CALL MESAGE (1, RTRN)
                RETURN
   15        IF (X(1,1).NE.13) GO TO 16
                CALL CLEARX (3)
                RETURN
   16        IF (P(1).EQ.0) RETURN
                IF (P(1).GT.1) GO TO 17
                   IF (OP(2).EQ.71) GO TO 14
                   IF (OP(2).EQ.73) GO TO 14
   17           P(1)=P(1)-1
                IF (P(1).NE.0) RETURN
                   IF (OP(2).GT.60) CALL DRPSTK
                RETURN
             END
      SUBROUTINE ADEXPD (RTRN)
C         DATE OF LAST CHANGE - 750125
C         PURPOSE:  ADD EXPONENT OF D TO THAT OF X(1)
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             RTRN=0
             J=10*X(1,16)+X(1,17)
             IF (X(1,15).EQ.13) J=-J
             IF (D(15).EQ.15) D(15)=0
             IF (D(16).EQ.15) D(16)=0
             K=10*D(15)+D(16)
             IF (D(14).EQ.13) K=-K
             J=J+K
             IF (J.GE.0) GO TO 1
                J=-J
                X(1,15)=13
                GO TO 2
    1        X(1,15)=15
    2        X(1,16)=J/10
             X(1,17)=J-X(1,16)*10
             IF (X(1,16).LT.10) GO TO 6
                IF (X(1,15).EQ.13) GO TO 3
                   K=9
C-                 "EXP OF A"="+ OVERFLOW"
                   J=12
                   GO TO 4
    3           K=0
                X(1,1)=15
C-              "EXP OF A"="+"
                J=15
    4           DO 5 I=2,17
    5              X(1,I)=K
                X(1,15)=J
                CALL MESAGE (7, RTRN)
    6        RETURN
             END






      SUBROUTINE EXPON (A,B,C,N)
C         DATE OF LAST CHANGE - 740210
C         ADD "N" TO THE EXPONENT "ABC" (I.E. SIGN, DIGIT, DIGIT)
          IMPLICIT INTEGER (A-Z)
             IF (B.EQ.15) B=0
             IF (C.EQ.15) C=0
             K=10*B+C
             IF (A.EQ.13) K=-K
             K=K+N
             IF (K.GE.0) GO TO 1
                K=-K
                A=13
                GO TO 2
    1        A=15
    2        B=K/10
             C=K-10*B
             RETURN
             END
      SUBROUTINE RECALL (START)
C         DATE OF LAST CHANGE - 750314
          IMPLICIT INTEGER (A-Z)
          LOGICAL TEMPF
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             GO TO (1, 5, 6), START
C ** START 1 - EXPLICIT REGISTERS (A, PI, LST X, LST Y)
    1           IF (CODE-24) 2, 3, 4
    2           RN=-3
                   GO TO 7
    3           RN=-4
                   GO TO 8
    4           RN=CODE-40
                   GO TO 7
C ** START 2 - "R" REGISTERS
    5        LFRC=1
             CALL REG (RTRN)
                IF (RTRN.EQ.1) GO TO 11
             IF (TEMPF) RETURN
C ** START 3 - RECALL INDICATED REGISTER (RN IN W)
    6        CALL REGNO (RTRN)
                IF (RTRN.EQ.1) GO TO 11
    7        IF (R(RN+5,2).NE.15) GO TO 8
                CALL MESAGE (5, RTRN)
                   IF (RTRN.EQ.1) GO TO 11
    8        CALL SETUP (RTRN)
                IF (RTRN.EQ.1) GO TO 11
             IF (X(1,1).EQ.13) GO TO 9
                CALL TRANS (.FALSE.)
                RETURN
    9        CALL TRANS (.FALSE.)
             IF (X(1,1).EQ.13) GO TO 10
                X(1,1)=13
                RETURN
   10        X(1,1)=15
   11        RETURN
             END
      SUBROUTINE STORE (START)
C         DATE OF LAST CHANGE - 750315
          IMPLICIT INTEGER (A-Z)
          DIMENSION OPCODE(19), A(2,17)
          LOGICAL TEMPF
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
          DATA OPCODE /12*0, 30, 31, 0, 40, 41, 0, 60/
             GO TO (1, 11, 18), START
C ** START 1 - LOOK FOR DESTINATION
    1        IF (OP(1).LT.70) GO TO 2
                CALL MESAGE (1, RTRN)
                RETURN
    2        OPCD=0
    3        LFRC=2
             CODE=31
    4        CALL FINDN (2, RTRN)
                IF (RTRN.EQ.1) GO TO 20
             IF (K.NE.0) GO TO 10
                IF (CODE.NE.25) GO TO 5
                   CALL REG (RTRN)
                      IF (RTRN.EQ.1) GO TO 20
                   IF (TEMPF) GO TO 3
                      GO TO 10
    5           IF (CODE.NE.23) GO TO 6
                   N=-3
                   RN=-3
                   GO TO 12
    6           IF (CODE.NE.51) GO TO 7
                   LFRC=5
                   CALL FDIGIT (1, RTRN)
                      IF (RTRN.EQ.1) GO TO 20
                   IF (TEMPF) GO TO 2
                      GO TO 18
    7           IF (CODE.EQ.13 .OR. CODE.EQ.14 .OR. CODE.EQ.16 .OR.
     *              CODE.EQ.17 .OR. CODE.EQ.19) GO TO 9
                   IF (CODE.NE.28) GO TO 8
                      IF (OPCD.EQ.0) RETURN
                         GO TO 2
    8              CALL MESAGE (3, RTRN)
                      IF (RTRN.EQ.1) GO TO 20
                   GO TO 2
    9           OPCD=OPCODE(CODE)
                GO TO 4
   10        TEMP=1
C ** START 2 - REGISTER NUMBER(S) KNOWN (HELD IN W [&DSP])
   11        CALL RANGE (RTRN)
                IF (RTRN.EQ.1) GO TO 20
   12        KMAX=RN
             DO 17 RN=N,KMAX
                IF (OPCD.EQ.0) GO TO 16
                   K=RN+5
                   IF (R(K,2).NE.15) GO TO 13
                      CALL MESAGE (5, RTRN)
                         IF (RTRN.EQ.1) GO TO 20
   13              DO 14 I=1,17
                      A(1,I)=X(1,I)
                      A(2,I)=R(K,I)
   14                 IF (A(2,I).EQ.15) A(2,I)=0
                   IF (A(1,2).EQ.15) A(1,2)=0
                   CALL COMBIN (A, 2)
                   DO 15 I=1,17
   15                 R(K,I)=A(1,I)
                   GO TO 17
   16           CALL TRANS (.TRUE.)
   17           CONTINUE
             IF (OP(1).EQ.0) OP(1)=1
                RETURN
C ** START 3 - FLAG NUMBER(S) KNOWN (HELD IN N [& RN])
   18        TEMP=1
             IF (X(1,1).EQ.13 .OR. X(1,2).EQ.0 .OR.
     *          X(1,15).EQ.13 .OR. X(1,2).EQ.15) TEMP=0
             DO 19 I=N,RN
                K=I+1
   19           UFLAG(K)=TEMP
   20        RETURN
             END


















      SUBROUTINE TRANS (STORE)
C         DATE OF LAST CHANGE - 740715
          IMPLICIT INTEGER (A-Z)
          LOGICAL STORE
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             K=RN+5
             IF (STORE) GO TO 4
                DO 1 I=1,17
    1              X(1,I)=R(K,I)
                IF (X(1,2).NE.15) GO TO 3
                   DO 2 I=2,17
    2                 X(1,I)=0
                   X(1,15)=15
    3           RETURN
    4        DO 5 I=1,17
    5           R(K,I)=X(1,I)
             IF (R(K,2).EQ.15) R(K,2)=0
             IF (R(K,1).EQ.13 .AND. R(K,2).EQ.0) R(K,1)=15
             RETURN
             END
      SUBROUTINE SCR (START)
C         DATE OF LAST CHANGE - 750303
          IMPLICIT INTEGER (A-Z)
          LOGICAL TEMPF
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             GO TO (1, 5, 8), START
C ** START 1 - FIND ARGUMENT
    1        CODE=50
             CALL CONTRL (3, 2)
             IF (CODE.NE.25) GO TO 2
                LFRC=3
                CALL REG (RTRN)
                   IF (RTRN.EQ.1) GO TO 10
                IF (TEMPF) GO TO 1
                   TEMP=1
                   GO TO 5
    2        IF (CODE.NE.23) GO TO 3
                N=-3
                RN=-3
                GO TO 6
    3        IF (CODE.NE.51) GO TO 4
                LFRC=4
                CALL FDIGIT (1, RTRN)
                   IF (RTRN.EQ.1) GO TO 10
                IF (TEMPF) GO TO 1
                   GO TO 8
    4        CALL MESAGE (3, RTRN)
                IF (RTRN.EQ.1) GO TO 10
             GO TO 1
C ** START 2 - REGISTER NUMBER(S) KNOWN (HELD IN W [&DSP])
    5        CALL RANGE (RTRN)
                IF (RTRN.EQ.1) GO TO 10
    6        DO 7 I=N,RN
                K=I+5
                DO 7 J=1,17
    7              R(K,J)=15
             RETURN
C ** START 3 - FLAG NUMBER(S) KNOWN (HELD IN N [& RN])
    8        DO 9 I=N,RN
                K=I+1
    9           UFLAG(K)=0
   10        RETURN
             END
      SUBROUTINE LSTKEY
C         DATE OF LAST CHANGE - 750315
          IMPLICIT INTEGER (A-Z)
          LOGICAL NEXT
          DIMENSION W2(16)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
             DO 1 I=1,16
                W2(I)=DSP(I)
    1           DSP(I)=11
             DSP(1)=15
    2        DSP(8)=0
             DSP(9)=LSTK/10
             DSP(10)=LSTK-10*DSP(9)
             CALL KYMODE (1)
             CALL OUTIN (2)
             IF (CODE.NE.27) GO TO 4
                DO 3 I=1,16
    3              DSP(I)=W2(I)
                RETURN
    4        IF (CODE.EQ.30) GO TO 2
                NEXT=.TRUE.
             RETURN
             END
















      SUBROUTINE KYMODE (START)
C         DATE OF LAST CHANGE - 741231
          IMPLICIT INTEGER (A-Z)
          LOGICAL STEP
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /OUTPT/ SKIP, DISPLY(32), PGMPTR
             GO TO (1, 2, 3), START+1
C ** START 0 - COMPLEMENT "STEP"
    1           STEP=.NOT.STEP
                RETURN
C ** START 1 - DISPLAY PROGRAM POINTER?
    2        IF (.NOT.STEP) RETURN
C ** START 2 - DISPLAY PROGRAM POINTER!
    3           DSP(1)=PGMPTR/1000
                DSP(2)=PGMPTR/100-10*DSP(1)
                DSP(3)=PGMPTR/10-100*DSP(1) -10*DSP(2)
                DSP(4)=PGMPTR/1-1000*DSP(1)-100*DSP(2)-10*DSP(3)
                RETURN
             END
      SUBROUTINE FLAG (START)
C         DATE OF LAST CHANGE - 750314
          IMPLICIT INTEGER (A-Z)
          LOGICAL TEMPF
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             IF (START.EQ.2) GO TO 1
C ** START 1 - FIND FLAG NUMBER
             LFRC=6
             CALL FDIGIT (1, RTRN)
                IF (RTRN.EQ.1) GO TO 2
             IF (TEMPF) RETURN
C ** START 2 - FLAG NUMBER KNOWN (HELD IN N)
    1        CALL SETUP (RTRN)
                IF (RTRN.EQ.1) GO TO 2
             K=N+1
             X(1,2)=UFLAG(K)
    2        RETURN
             END
      SUBROUTINE SETUP (RTRN)
C         DATE OF LAST CHANGE - 750416
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             RTRN=0
             IF (X(1,2).EQ.15) RETURN
             IF (OP(1).NE.0) GO TO 2
                CALL TESTUP (RTRN)
                   IF (RTRN.EQ.1) GO TO 4
                OP(1)=50
                CALL COLAPS (RTRN)
                   IF (RTRN.EQ.1) GO TO 4
    1           CALL ENTRUP
                RETURN
    2        IF (OP(1).EQ.1) GO TO 5
                IF (OP(1).LT.72) GO TO 3
                   CALL MESAGE (1, RTRN)
                   RTRN=1
                   RETURN
    3           IF (X(SMAX,2).EQ.15) GO TO 1
                   CALL MESAGE (8, RTRN)
    4              RTRN=1
                   RETURN
C        CODE = 81, 82, ... WHEN "LANGUAGE FUNCTION" BEING FORMED
    5        IF (CODE.GT.79) GO TO 3
             TEMP=RN
             RN=-2
             CALL TRANS (.TRUE.)
             RN=TEMP
             CALL CLEARX (2)
             RETURN
             END















      SUBROUTINE TESTUP (RTRN)
C         DATE OF LAST CHANGE - 740625
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
             RTRN=0
             IF (X(SMAX,2).EQ.15) RETURN
             IF (OP(2).LT.50) GO TO 1
                IF (P(1).EQ.0) GO TO 2
    1              CALL MESAGE (8, RTRN)
                   RTRN=1
    2        RETURN
             END
      SUBROUTINE ENTRUP
C         DATE OF LAST CHANGE - 740630
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             KMAX=SMAX-1
             DO 1 I=1,KMAX
                J=SMAX-I
                K=J+1
                P(K)=P(J)
                OP(K)=OP(J)
                DO 1 N=1,17
    1              X(K,N)=X(J,N)
C-           IF (X(SMAX,2).NE.15) "TURN ON 'STACK FULL' LIGHT"
             CALL CLEARX (1)
             RETURN
             END










      SUBROUTINE DROP (START)
C         DATE OF LAST CHANGE - 750212
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             GO TO (1, 2, 3), START
C ** START 1 - DROP S(2), ..., S(SMAX)
    1        J=1
             GO TO 4
C ** START 2 - DROP S(3), ..., S(SMAX)
    2        P(1)=P(2)
             J=2
             GO TO 4
C ** START 3 - DROP S(PTR+1), ..., S(SMAX)
    3        J=PTR
    4        KMAX=SMAX-1
             DO 5 I=J,KMAX
                IF (I.GT.1 .AND. X(I,2).EQ.15) GO TO 6
                JJ=I+1
                P(I)=P(JJ)
                OP(I)=OP(JJ)
                DO 5 K=1,17
    5              X(I,K)=X(JJ,K)
    6        IF (X(SMAX,2).EQ.15) RETURN
                OP(SMAX)=0
                P(SMAX)=0
                X(SMAX,1)=15
                X(SMAX,2)=15
                DO 7 I=3,17
    7              X(SMAX,I)=0
                X(SMAX,15)=15
C-              "TURN OFF 'STACK FULL' LIGHT"
                RETURN
             END
      SUBROUTINE NUMBER (START, RTRN)
C         DATE OF LAST CHANGE - 750130
          IMPLICIT INTEGER (A-Z)
          LOGICAL NEXT
          COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
             RTRN=0
             IF (START.EQ.2) GO TO 5
C ** START 1 - FIND A NUMBER (0-9)
    1        CALL CONTRL (1, 2)
             IF (CODE.GT.9) GO TO 2
                W(2)=CODE
                RETURN
    2        IF (LFRC.NE.0) GO TO 3
                NEXT=.TRUE.
                RTRN=1
                RETURN
    3        IF (CODE.EQ.18) GO TO 4
                CALL MESAGE (3, RTRN)
                   IF (RTRN.EQ.1) GO TO 9
                GO TO 1
    4        CALL ARGMNT (1)
             RTRN=1
             RETURN
C ** START 2 - NUMBER FOUND FROM EXPRESSION (HELD IN W)
    5        IF (W(17).EQ.0 .AND. W(16).EQ.0) GO TO 6
                CALL MESAGE (4, RTRN)
                RTRN=1
                RETURN
C-
    6        TYPE 7
    7        FORMAT (10X, 'GOT TO "NUMBER AT "START 2" SOMEHOW!'/)
             RTRN=1
C-
C-  6        GO TO (7, 8), CODE-7
C-  7        CALL P (2)
C-              RETURN
C-  8        CALL STORE (2)
    9           RETURN
             END
      SUBROUTINE FINDN (START, RTRN)
C         DATE OF LAST CHANGE - 750104
          IMPLICIT INTEGER (A-Z)
          LOGICAL NEXT
          COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             RTRN=0
             GO TO (1, 2, 3), START
    1        KMAX=1
                GO TO 4
    2        KMAX=2
                GO TO 4
    3        KMAX=3
    4        NEXT=.FALSE.
             K=0
             I=CODE
    5        CALL CONTRL (3, 2)
             IF (CODE.GT.9) GO TO 6
                W(17)=K
                K=K+1
                W(K+1)=CODE
                IF (K.LT.KMAX) GO TO 5
                   RETURN
    6        IF (K.GT.0) GO TO 7
                IF (CODE.NE.18) GO TO 11
                   CALL ARGMNT (1)
                   RTRN=1
                   RETURN
    7        IF (CODE.NE.28) GO TO 8
                K=K-1
                W(17)=K-1
                CODE=W(K+1)
                IF (K.EQ.0) CODE=I
                GO TO 5
    8        IF (CODE.NE.27) GO TO 9
                K=0
                GO TO 11
    9        IF (CODE.NE.26) GO TO 10
                K=0
   10        NEXT=.TRUE.
   11        RETURN
             END
      SUBROUTINE REG (RTRN)
C         DATE OF LAST CHANGE - 750318
          IMPLICIT INTEGER (A-Z)
          LOGICAL TEMPF
          COMMON /INPUT/ CODE, EXPR(50), KEY,  OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             RTRN=0
             IND=0
             TEMPF=.FALSE.
    1        CALL FINDN (2, RTRN)
                IF (RTRN.EQ.1) GO TO 14
             IF (K.NE.0) GO TO 11
                IF (CODE.NE.25) GO TO 4
                   IF (IND.NE.15) GO TO 3
                      CALL MESAGE (4, RTRN)
    2                 RTRN=1
                      RETURN
    3              IND=IND+1
                   LFRC=0
                   GO TO 1
    4           IF (CODE.NE.23) GO TO 7
                   IF (R(2,2).NE.15) GO TO 5
                      CALL MESAGE (5, RTRN)
                         IF (RTRN.EQ.1) GO TO 14
    5              DO 6 I=1,17
    6                 W(I)=R(2,I)
                   IF (W(2).EQ.15) W(2)=0
                   GO TO 11
    7           IF (CODE.NE.22) GO TO 8
                   W(2)=1
                   W(3)=6
                   W(15)=15
                   W(16)=0
                   W(17)=1
                   GO TO 11
    8           IF (CODE.EQ.26) GO TO 2
                IF (CODE.EQ.27) GO TO 2
                IF (CODE.NE.28) GO TO 10
                   IF (IND.EQ.0) GO TO 9
                      IND=IND-1
                      CODE=25
                      GO TO 1
    9              TEMPF=.TRUE.
                   RETURN
   10           CALL MESAGE (3, RTRN)
                   IF (RTRN.EQ.1) GO TO 14
                GO TO 1
   11        IF (IND.EQ.0) GO TO 14
                CALL REGNO (RTRN)
                   IF (RTRN.EQ.1) GO TO 14
                RN=RN+5
                IF (R(RN,2).NE.15) GO TO 12
                   CALL MESAGE (5, RTRN)
                      IF (RTRN.EQ.1) GO TO 14
   12           DO 13 I=1,17
   13              W(I)=R(RN,I)
                IF (W(2).EQ.15) W(2)=0
                IND=IND-1
                GO TO 11
   14        RETURN
             END
      SUBROUTINE RANGE (RTRN)
C         DATE OF LAST CHANGE - 750225
          IMPLICIT INTEGER (A-Z)
          LOGICAL TEMPF
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             RTRN=0
             TEMPF=.TRUE.
    1        CALL REGNO (RTRN)
                IF (RTRN.EQ.1) GO TO 6
             IF (RN.NE.16) GO TO 2
                CALL MESAGE (4, RTRN)
                RETURN
    2        IF (TEMP.EQ.1) GO TO 5
                N=RN
                TEMPF=.FALSE.
                TEMP=TEMP-1
                DO 3 I=1,13
    3              W(I)=DSP(I)
                W(14)=0
                DO 4 I=14,16
    4              W(I+1)=DSP(I)
                GO TO 1
    5        IF (TEMPF) N=RN
             IF (RN.GE.N) GO TO 6
                TEMP=RN
                RN=N
                N=TEMP
    6        RETURN
             END













      SUBROUTINE REGNO (RTRN)
C         DATE OF LAST CHANGE - 741126
C         PURPOSE: CONVERT W TO INTEGER IN RN; CHECK FOR RN TOO BIG
          IMPLICIT INTEGER (A-Z)
          COMMON /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             RTRN=0
             K=21
             CALL INTGER
             KMAX=RN
             K=0
             CALL INTGER
             IF (RN.LE.KMAX+1) GO TO 1
                CALL MESAGE (4, RTRN)
                RTRN=1
    1        RETURN
             END
      SUBROUTINE ARGMNT (START)
C         DATE OF LAST CHANGE - 750225
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             GO TO (1, 5), START
C ** START 1 - FORM GENERAL ARGUMENT
    1        IF (LFRC.NE.0) GO TO 2
                CALL MESAGE (3, RTRN)
                RETURN
    2        CODE=LFRC+80
             LFRC=0
C-           FOLLOWING 4 LINES ARE FOR A 2 ARGUMENT "LANGUAGE FUNCTION"
C-           IF (CODE.LT.90) GO TO 3
C-              PTR=2
C-              TEMP=2
C-              GO TO 4
    3        PTR=1
             TEMP=1
             IF (CODE.GT.81 .AND. CODE.LT.86) TEMP=2
    4        CALL FUNCTN (5)
             RETURN
C ** START 2 - RETURN ARGUMENT(S) TO "LANGUAGE FUNCTION" IN W ([&D] &DSP)
    5        TEMP=PTR-1
             N=1
    6        PTR=PTR-1
             IF (X(1,15).NE.13) GO TO 8
                DO 7 I=1,17
    7              W(I)=0
                GO TO 9
    8        K=6
             CALL ROUND
    9        CALL DROP (1)
             IF (OP(1).GT.70) GO TO 16
                N=N+1
                IF (N.GT.2) GO TO 12
                   DO 10 I=1,13
   10                 DSP(I)=W(I)
                   DO 11 I=14,16
   11                 DSP(I)=W(I+1)
                   GO TO 6
   12           IF (N.GT.3) GO TO 15
                   DO 13 I=1,13
   13                 D(I)=W(I)
                   DO 14 I=14,16
   14                 D(I)=W(I)
                   GO TO 6
   15           CALL MESAGE (82, RTRN)
                RETURN
   16        PTR=X(1,2)-80
             IF (PTR.EQ.2) OPCD=X(1,5)
             IF (P(1).EQ.0) GO TO 17
                CALL CLEARX (2)
                GO TO 18
   17        CALL DROP (1)
   18        GO TO (20, 21, 22, 23, 23, 23, 19, 24, 24), PTR
   19           CALL MESAGE (83, RTRN)
                RETURN
   20        CALL RECALL (3)
                RETURN
   21        CALL STORE (2)
                RETURN
   22        CALL SCR (2)
                RETURN
   23        CALL FDIGIT (2, RTRN)
                RETURN
   24        CALL NUMBER (2, RTRN)
                RETURN
             END
























      SUBROUTINE INTGER
C         DATE OF LAST CHANGE - 741218
          IMPLICIT INTEGER (A-Z)
          DIMENSION S(17)
          COMMON /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             RN=0
             IF (K.GT.0) GO TO 3
    1        DO 2 I=1,17
    2           S(I)=W(I)
             GO TO 7
    3           IF (S(2).NE.15) GO TO 5
                   DO 4 I=2,17
    4                 S(I)=0
                   S(15)=15
                   GO TO 7
    5           DO 6 I=1,17
    6              S(I)=R(K,I)
    7        IF (S(15).EQ.13) RETURN
                K=S(16)*10+S(17)+1
                IF (K.LT.13) GO TO 8
                   RN=99999
                   RETURN
    8           DO 9 I=1,K
    9              RN=RN*10+S(I+1)
                RETURN
             END
      SUBROUTINE ROUND
C         DATE OF LAST CHANGE - 750123
C         PURPOSE:  ROUND X(1,I) TO  K  DIGITS & PUT RESULT IN W(I)
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
    1        DO 2 I=1,17
    2           W(I)=X(1,I)
             IF (K.NE.15) GO TO 3
                W(15)=12
                RETURN
    3        IF (W(2).EQ.15) W(2)=0
             CNT=K+2
             IF (W(CNT)-5) 11, 4, 7
C        TEST DIGIT = 5 (TEST FURTHER)
    4           CNT=14
                KLAX=K+3
    5           IF (W(CNT).GT.0) GO TO 7
                   IF (CNT.EQ.KMAX) GO TO 6
                      CNT=CNT-1
                      GO TO 5
    6           CNT=K+1
                IF (2*(W(CNT)/2) .EQ. W(CNT)) GO TO 11
C        ROUND UP
    7              CNT=K+1
    8              W(CNT)=W(CNT)+1
                   IF (W(CNT).LT.10) GO TO 11
                      W(CNT)=W(CNT)-10
                      CNT=CNT-1
                      IF (CNT.GT.1) GO TO 8
C            [W(2) OVERFLOWED; SHIFT RIGHT & SET W(2)=1]
                         CNT=K+2
    9                    W(CNT)=W(CNT-1)
                         IF (CNT.LE.3) GO TO 10
                            CNT=CNT-1
                            GO TO 9
   10                    W(2)=1
                         K=K+1
                         CALL EXPON (W(15), W(16), W(17), 1)
                         IF (W(16).LT.10) GO TO 11
                            K=15
                            GO TO 1
C        PUT 0'S IN REMAINDER OF W
   11        KMAX=K+1
             DO 12 I=KMAX,13
   12           W(I+1)=0
             RETURN
             END
      SUBROUTINE FDIGIT (START, RTRN)
C         DATE OF LAST CHANGE - 750315
          IMPLICIT INTEGER (A-Z)
          LOGICAL TEMPF
          COMMON /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             RTRN=0
             IF (START.EQ.2) GO TO 7
C ** START 1 - FIND A DIGIT (0-9, A)
             TEMPF=.FALSE.
    1        CALL CONTRL (3, 2)
             IF (CODE.GT.9) GO TO 2
                N=CODE
                GO TO 3
    2        IF (CODE.NE.23) GO TO 4
                N=10
    3           RN=N
                RETURN
    4        IF (CODE.NE.18) GO TO 5
                CALL ARGMNT (1)
                RTRN=1
                RETURN
    5        IF (CODE.NE.28) GO TO 6
                TEMPF=.TRUE.
                RETURN
    6        CALL MESAGE (3, RTRN)
                IF (RTRN.EQ.1) GO TO 13
             GO TO 1
C ** START 2 - DIGIT HAS BEEN FOUND FROM EXPRESSION
    7        CALL RANGE (RTRN)
                IF (RTRN.EQ.1) GO TO 13
             IF (RN.GT.11) GO TO 8
                IF (N.LT.11) GO TO 9
    8              CALL MESAGE (4, RTRN)
                   RTRN=1
                   RETURN
    9        GO TO (10, 11, 12), PTR-3
   10        CALL SCR (3)
                RETURN
   11        CALL STORE (3)
                RETURN
   12        CALL FLAG (2)
   13           RETURN
             END